perm filename PLTSRT.OLD[NEW,LCS]2 blob
sn#312583 filedate 1977-10-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C SUBRS. SLUR, (JUGGLE), (LOOP), PLTSRT, (LINES), (HOMER),
C00026 ENDMK
C⊗;
C SUBRS. SLUR, (JUGGLE), (LOOP), PLTSRT, (LINES), (HOMER),
C (PLACE), (FINDIT), SCL, FORMAT
SUBROUTINE SLUR
IMPLICIT INTEGER(A-Q,T-Z)
COMMON/SLR/ SLURX(32)
REAL CENTR
COMMON /XRN/RN(2000) /PLTR/PLT,RHT,RDIS
COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
1 J5,J6,J7,J8,J9,J10,J11,JQ(8),RJ
COMMON/PTR/PWDS(250),ITEM,L,I,IX /STF/RSTFAC(0/7),RSTJ2
COMMON/ALF/INP,SLURY(72)
CF DATA RZZ/2.8/
C DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8
CCC IF(JA.NE.12)GO TO 2
CF RA=5.96*RSTJ2*R5
CF L=3
CF J8=J8*RDIS
CF IF(J7.LE.J6)J7=J7+360
CF KQ=6
CF IF(PLT)KQ=1
CF10 DO 3 K=J6,J7,KQ
CF R=K
CF CALL LINES(R3+RA*SIND(R),CENTR+RA*COSD(R),L)
CF3 L=2
CF J8=J8-1
CF IF(J8)RETURN
CF RA=RA+1/RDIS
CF L=3
CF GO TO 10
CJA=12 DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2,P8=THICK(EXPANDS
CCC CALL CIRCLE
CCC RETURN
C*** SLURS *** 5, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
C P9=NUM IN BRACKET(IF NON-ZERO)
2 J10=1
J4=-1
J5=1
C ↑↑↑↑ FOR DPY ONLY (32 SEGS ARE USED)
TWICE=-1
IF(R6)R6=202
C R6=NEG. IS FOR PAGE-LAYOUT PROG. TELLS WHICH NOTE TO SLUR TO.
21 RST7=RSTJ2*7.
RJ=ABS(R7)
C R7+100=LEFT HALF SLUR, +200=RIGHT HALF, +300=REVERSE DIRECTION.
IF(RJ.LT.100)RJ=-1
R7=AMOD(R7,100.0)
IF(RJ.LT.300)GO TO 20
RJ=0
CC*** NOT YET! R5=R5-(2*R7)
C R5 THINKS THE SLUR ISN'T REVERSED.
C TO USE THIS ADD R6=SQRT((R5-R4)**2+(R6-R3)**2)+R3(WITH FACTORS)
20 RQQ=R5-R4
IF(R6.GT.1000)CALL RNOTE(R6)
GO TO (5,6,7),J8+4
GO TO 4
CC5 R=32
5 R=30
C AFTER DOTTED NOTE
GO TO 8
CC6 R=22
6 R=18
C BETWEEN NOTES
CC8 RX=-1.3
8 RX=-0.75
GO TO 9
7 R=7
RX=RSTJ2
9 CALL RJBX(R)
R6=R6+RX
4 RXX=RHORZ(R6)-R3
RTILT=RQQ*RST7
80 RX=SQRT(RXX**2+RTILT**2)
IF(J8.NE.-1)GO TO 1
IF(RQQ.GT.8)RQQ=8
IF(RQQ.LT.-8)RQQ=-8
RQQ=RQQ*RSTFAC(J2)*1.0
IF(R7)RQQ=-RQQ
R3=R3-RQQ
C MOVES STEEP SLUR LEFT OR RIGHT IF P8=-1
1 R=CENTR
IF(J8.GT.0)GO TO 180
C JUMP FOR BRACKETS
L=32
CALL SLOOP
CF RB=RX/71.
CF DO 81 K=0,71
CF81 SLURX(K+1)=RB*(K)+R3
CF RA=R7*RST7
CF41 IF(R9.EQ.0)R9=RZZ
CF R=R+RA
CF L=0
CF DO 40 K=36,1,-1
CF L=L+1
CF RW=R-RA*(K/36.)**R9
CF SLURY(L)=RW
CF40 SLURY(73-L)=RW
CF L=72
CF89 IF(RTILT.EQ.0)GO TO 87
CF RW=ATAN2(RTILT,RXX)
CF RA=SIN(RW)
CF RB=COS(RW)
CF RZ=SLURX(1)
CF RW=SLURY(1)
CF DO 83 K=1,L
CF R=SLURX(K)-RZ
CF RXX=SLURY(K)-RW
CF SLURX(K)=RB*R-RA*RXX+RZ
CF83 SLURY(K)=RB*RXX+RA*R+RW
87 IF(J4)CALL LINES(SLURX(J10),SLURY(J10),3)
J6=J10
J7=L
IF(J4.NE.0)GO TO 22
CALL EXCH(J6,J7)
J5=-1
22 DO 88 K=J6,J7,J5
88 CALL LINES(SLURX(K),SLURY(K),2)
IF(J5.GT.1)CALL LINES(SLURX(L),SLURY(L),2)
C DISPLAY END POINT OF SLUR
IF(TWICE)RETURN
TWICE=TWICE-1
GO TO 182
180 RW=R+R7*RST7
TWICE=-1
CC KQ=1
J5=1
RX=RX+R3
CC RA=(R5-R4)*RST7
IF(J9.EQ.0)GO TO 181
RZ=RTILT/(RX-R3)
TWICE=2
CC RZ=RX-R3
RXX=RX
RWID=(R3+RXX)/2.
182 IF(TWICE.EQ.1)GO TO 183
C DOES LEFT SIDE FIRST.
IF(TWICE.EQ.0)GO TO 184
C LAST IS NUMBER.
J8=2
RC=RSTJ2*13.
RX=RWID-RC
RWW=RTILT
185 RTILT=RZ*(RX-R3)
C PUT IN FUNC. HERE FOR THIS SLOPE AND FOR PART. BEAMS.
GO TO 181
183 J8=3
RX=RXX
RTILT=RWW
RXX=R3
R3=RWID+RC
RXX=RZ*(R3-RXX)
R=R+RXX
RW=RW+RXX
GO TO 185
181 SLURX(1)=R3
SLURY(1)=R
SLURX(2)=R3
SLURY(2)=RW
SLURX(3)=RX
SLURY(3)=RW+RTILT
SLURX(4)=RX
SLURY(4)=R+RTILT
L=4
IF(J8.EQ.2)L=3
IF(J8.EQ.3)J10=2
CC TWICE=-1
GO TO 87
184 J3=RWID
C PUT IN VERT. POS. WHEN SLOPE!
R4=RQQ/2.+R4+R7-1.
R6=1.
C R7=1 IS FOR ITALICS
R7=1
C OR USE 1 FOR ITALIC NUMBERS.
R8=0
CALL MAKNUM(R9)
END
C******** JUGGLER ********
CF SUBROUTINE JUGGLE
CF IMPLICIT INTEGER(A-Z)
CF REAL PWDS,RN
CF COMMON /DL/X22,SAVER,NAME /XRN/RN(2000)
CF COMMON/PTR/PWDS(250),ITEM,L,I,IX/DPY/ST(4000),WDS(250),MEDIT,IGO
CF ITEM=ITEM-1
CF JX=RN(MEDIT)+3
C WD CNT OF OLD ITEM
C I-IX IS WD CNT OF NEW ITEM
CF JY=IX
CF Z=I-IX-JX
C SPACE CHANGE
CF IF(Z)2751,172,751
CF751 CALL LOOP(I-1,MEDIT+JX,-1,Z,0,RN)
CF JY=IX+Z
CF GO TO 172
CF2751 CALL LOOP(MEDIT+JX+Z,IX+Z-1,1,0,-Z,RN)
CF172 J=RN(JY)+2
CF CALL LOOP(0,J,1,MEDIT,JY,RN)
CF I=IX+Z
CF1751 X=ITEM+1
CF JX=WDS(X22+1)-WDS(X22)
CF J=WDS(X+1)-WDS(X)
CF Y=J-JX
CF JX=WDS(X)+Y+1
CF IF(Y)2851,182,282
CF282 CALL LOOP(WDS(X+1)+2,WDS(X22),-1,Y,0,ST)
CF GO TO 182
CF2851 CALL LOOP(WDS(X22+1)+Y+1,WDS(X)+Y+1,1,0,-Y,ST)
CF JX=WDS(X)+1
CF182 CALL LOOP(1,J,1,WDS(X22)+1,JX,ST)
CF DO 183 K=X22+1,X
CF PWDS(K)=PWDS(K)+Z
CF183 WDS(K)=WDS(K)+Y
CF ST(2)=WDS(X)
CF X22=0
CF END
CF SUBROUTINE LOOP(I,J,K,L,M,N)
CF DIMENSION N(1)
CF MM=M-L
CF DO 1 NN=I+L,J+L,K
CF1 N(NN)=N(NN+MM)
CF END
CXX SUBROUTINE PLTSRT
C SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING.
CF IMPLICIT INTEGER(S-Z)
CXX COMMON /XRN/RN(2000) /PTR/PWDS(250),ITEM,L,I,IX
CXX COMMON/DPY/Q(3000),P(1000),WDS(250),MEDIT,IGO
C Q AND P OCCUPY DPY BUFFER. Q IS FOR OVERFLOW OF RN.
CXX CALL PSRT(P)
CF DO 4 K=1,ITEM
CF L=PWDS(K)
CD¬Q=RN(L+3)
CF P(K)=A+1000*RN(L+2)
CF4 IF(A.LT.0)GO TO 77
CF IF(RN(L+1).NE.16.)GO TO 177
CF77CF P(K)=-10000
C PLOTS ALL NEG. HORIZ. POSITIONS AND WORDS(CODE 16) FIRST.
CF177CF M=I
CF IF(I.LT.1500)I=1500
CF Y=I
CF I=I+M-1
CF M=Y
C M IS IN MAIN PROG., LEAVES 1500 WDS IN RN FOR "NOIR" DATA.
CF2CF A=P(1)
CF L=1
CF DO 1 K=1,ITEM
CF IF(A.LE.P(K))GO TO 1
CF A=P(K)
CF L=K
CF1CF CONTINUE
CF IF(A.EQ.10000.)RETURN
C ALL ITEMS HAVE NOW BEEN SHUFFLED
CF V=PWDS(L)
CF P(L)=10000
CF L=RN(V)+2
CF CALL LOOP(0,L,1,Y,V,RN)
CF Y=Y+L+1
CF GO TO 2
CXX END
CX SUBROUTINE BOX(I,R)
CX COMMON/SIZ/RSZ,JCEN,KCEN /XRN/RN(2000) /STF/RSTFAC(-3/4),RSJ/C/L,K
CX COMMON/POSI/STFF(-3/4),JJ2,POS /RINP/RX(800),N(100)
CX IF(I)GO TO 4
CX K=R
CX K=(STFF(K)+AMOD(RN(I+4),100.0)*7.*RSTFAC(K)
CX 1 -40.0)*RSZ-KCEN
C ↑↑↑↑ WAS -60.0 10/74
C AMOD IS FOR MINI NOTES AND CLEFS
CX L=RHORZ(RN(I+3))*RSZ-JCEN
CX IF(IABS(L).GT.550)L=511
CX IF(IABS(K).GT.550)K=511
CC1 CALL ALINE(L,K,L+50,K)
CC CALL RVECT(0,100)
CC CALL RVECT(-50,0)
CC CALL RVECT(0,-100)
CC L=L+25
CC2 CALL ALINE(L,K-25,L,K+125)
CC3 CALL DPYOUT(1)
CX CALL SETCUR(L,K,0)
CX RETURN
CX4 IF(I.LT.-1)GO TO 5
CX CALL DPYSET(3,N,100)
CX CALL DPYBRT(3)
CX5 L=RHORZ(R)*RSZ-JCEN
CX IF(IABS(L).GT.550)GO TO 6
C DOESN'T TRY TO DRAW LINE OFF SCREEN
CX CALL SETPOG(3)
CX CALL ALINE(L,-511,L,511)
CX CALL DPYOUT(3)
CX6 CALL SETPOG(1)
CX END
CC SUBROUTINE LINES(A,B,L)
CC COMMON/DST/BB,CC
CC COMMON /SIZ/RSZ,JCEN,KCEN /FL/IC,NZ,NX,RZ,XGP
CC COMMON/DL/IXRX,SAVER,AA /PLTR/IPLT,RHT,DIS
CC COMMON R2,JA,CENTR,JB,RJQ(20),JQ(20)
CC COMMON/DPY/JJ(4000),WDS(250),MEDIT,IGO
CC EQUIVALENCE (ITOP,JJ(3999)),(IBOT,JJ(4000))
CC 1,(JJ2,JJ(2))
CC DATA BB/.008/,CC/3.5/
C SET XGP TO 1200.0 FOR MARGIN IN XEROX COPIES
CC GO TO 23
CC
CC22 IF(JQ(1).NE.0)GO TO 23
CC IF(CC.EQ.1000)GO TO 23
C ABOVE TO SKIP DISTORTION ON COMMAND
C CHANGE ABOVE TO 'JFCL' IN DDT TO USE NEXT ITEMS.
C USE THIS IN DDT TO DISTORT ITEMS. CC MUST BE > DD
CC B=B*(CC-BB*ABS(A))
C CC IS HGT FACTOR.
CC23 IF(IPLT)GO TO 2
CC M=A*RSZ
CC N=B*RSZ
CC IF(RSZ.LE.0.8571)GO TO 3
C NEXT FOR DISPLAY MAGNIFICATION
CC M=M-JCEN
CC N=N-KCEN
CC IF(JA.NE.8)GO TO 5
C NEXT INSURES DISPLAY OF STAFF LINES
CC IF(M.GT.511)M=511
CC IF(M.LT.-511)M=-511
CC5 IF(IABS(M).GT.512)GO TO 77
CC IF(IABS(N).LT.512)GO TO 4
C NOW DRAWS INVISIBLE VECT. IF IT GOES OFF THE SCREEN.
CC77 KZ=-1
CC RETURN
CC4 IF(KZ.EQ.0)GO TO 6
CC KZ=0
CC GO TO 1
CC3 IF(JA.EQ.44)GO TO 6
C JA=44=BAR LINES - THEY DON'T FIGURE IN MAX. HGT.
CC K=B
CC IF(K.GT.ITOP)ITOP=B
CC IF(K.LT.IBOT)IBOT=B
CC6 IF(JJ2.GT.3990)RETURN
CC IF(L.EQ.3)GO TO 1
CC CALL AVECT(M,N)
CC RETURN
CC1 CALL AIVECT(M,N)
CC RETURN
CC2 IF(IPLT.EQ.-2)RETURN
C RXGP SETS UP-DOWN POS. ON XEROX PAPER (FRACTIONAL POSITIONS POSSIBLE.)
CC9 M=ROFF(A*DIS)
CC N=ROFF(B*RHT)
CC8 CALL PLOT(M,N,L)
CC END
C****** FOR 'HOMING' OF BEAMS AND CHORD NOTES ***********
CF SUBROUTINE HOMER
CF IMPLICIT INTEGER(A-Q,S-Z)
CF REAL PWDS,DISX,A,B,PLACE,STFF
CF COMMON /STF/RSTFAC(-3/4),RSTJ2
CF COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /POSI/STFF(-3/4),JJ2,POS
CF COMMON /XRN/RN(2000) /PTR/PWDS(250),ITEM,L,I,IX
CF COMMON/ALF/QQ(3),K,RA,RB,N,RG,M,X,RE,RF,A,B,DISX,INP(58)
CF EQUIVALENCE (R3,RJQ(1)),(R6,RJQ(4)),(J11,JQ(9)),(RD,RN(2000))
CF 1,(R7,RJQ(5)),(R9,RJQ(7)),(R11,RJQ(9)),(R13,RJQ(11))
CF 1,(J10,JQ(8)),(R8,RJQ(6)),(J7,JQ(5))
CF IF(JA.EQ.6)GO TO 9
CF IF(R13.NE.0)GO TO 10
C FOR GENL HOMING; WORDS; BEAMS; STEMS;
CF IF(JQ(1).EQ.0)GO TO 197
C TO HOME IN ON NOTE ON DIFFERENT STAFF.
CF JJ2=R2
CF K=PWDS(JJ2)
CF L=PWDS(JQ(1))
CF RA=RN(K+3)
CF RB=RN(L+3)
C RB=POS OF NOTE, RA=POS(P3) OF BEAM
CF N=0
CF IF(RN(L+5).LT.20)N=-1
C -1 MEANS STEM IS UP
CF RG=-(AMOD(RN(K+7),10.)-1.)*11./7.
C SPACE FOR THE NUMB. OF BEAMS
CF J11=RN(L+2)
CF M=0
CF IF(RN(K+7).LT.20.)M=-1
CF X=RN(K+2)
C THE STAFF NUMS. X=BEAM J11=NOTE
CF R3=RSTFAC(X)
CF R9=RSTFAC(J11)/R3
CF R8=R3*14.54/5.96
C R8=WIDTH OF NOTE
C******* 5/74 BOTH STAVES MUST BE SAME SIZE - MOST LIKELY ********
CF R7=96./7.
C MUST BE DOUBLE STEM LENGTH
CF RD=RN(L+8)
CCCF IF(RD.EQ.999)RD=0
C THE STEM LENGTH
CF3 IF(M.NE.N)GO TO 5
CF R8=0
CF R7=0
CF RG=0
CF GO TO 4
CF5 IF(M.EQ.0)GO TO 4
CF R7=-R7
CF R8=-R8
CF RD=-RD
CF RG=-RG
C NOT OK IF DIFF SIZES AND RA.GT.RB ****** 5/74
CF4 RN(K+6)=RB+R8
C SETS CORRECT HORIZANTAL PARAM OF BEAM.
CF RF=7.*R9
CF RE=(STFF(J11)-STFF(X))/RF
C DIST BETWEEN STAVES.
CF RN(K+5)=RN(L+4)+RE+(R7+RD+RG)*R9
CF RETURN
C*********************************************************
C NEXT ADJUSTS STEMS WHEN BEAMS ARE USED.
CF197 JJ2=-1
CF R3=R2
CF DO 191 K=1,ITEM
CF L=PWDS(K)
CF IF(RN(L+1).NE.6)GO TO 191
CF IF(RN(L+2).EQ.R3)GO TO 77
CF IF(R3.LT.5.)GO TO 191
C TYPE 19 99 FOR ALL STAVES
CF77 RG=RN(L+7)
CF IF(RN(L).EQ.8)GO TO 191
CF IF(RG.LT.10.)GO TO 191
C FINDS BEAMS.
CF A=RN(L+3)-.01
CF B=RN(L+6)+.01
C POS 1 AND 2
CF DISX=B-A
C DISTANCE IN REAL STEPS
CF RB=AMOD(RN(L+5),100.0)
C NOTE 2
CF RF=AMOD(RN(L+4),100.0)
CF RD=RB-RF
C HEIGHT
CF R2=RN(L+2)
C ↑↑↑ USED IN 'FINDIT'
CF X=RG/10.
C STEM DIRECT.
CF DO 192CF N=1,ITEM
CF IF(FINDIT(N))GO TO 192
CF IF(RN(L).EQ.8)GO TO 192
CF IF(RN(L+8).EQ.1000.)GO TO 192
C SKIPS SLASHED GRACE NOTES (P8=1000 OR P10=1)
C FINDIT IS NEG. IF(RN(L+1).NE.1.OR.RN(L+3))
CF RC=RN(L+3)
CF IF(RC.LT.A)GO TO 192
CF IF(RC.GT.B)GO TO 192
C WHAT'S LEFT IS IN BEAM AREA IF STEM DIR. IS OK.
CF IF(X.NE.IFIX(RN(L+5)/10.))GO TO 192
CF RC=RC-A
CF193 RE=AMOD(RN(L+4),100.0)
CF RC=RD*RC/DISX+RF
CF RG=RN(L+7)
CF RN(L+7)=RG-AMOD(RG,10.0)+AMOD(RG,1.0)
C DELETES TAILS WITHOUT REMOVING DOTS OR SPACING OF DOTS.
C FRACTIONAL NOTE #
CF195 RA=RC-RE
CF IF(X.EQ.2)RA=-RA
CF IF(RA.EQ.0)RA=999.
CF196 RN(L+8)=RA
C FRACTIONAL NOTE # - FIRST NOTE OF GROUP + THIS NOTE # ALL *7.
CF IF(JJ2)JJ2=N
C SAVES # OF FIRST ITEM FOUND
CF192 CONTINUE
CF191 CONTINUE
CF RETURN
C*********************************************************
CF9 IF(J11.LT.0)RETURN
C IF P11=-1 NO HOMING
CF X=R7/10.
CF IF(X)X=-X
C X IS STEM DIRECTION
CF RA=R9
C R9= POS3
CF RC=-1.
CF IF(R9.NE.0)RC=-2.
CF IF(J10/10.EQ.3)RC=-3
C RC=1 ESCAPES FROM LOOP.
C HOMING RANGE FOR BEAMS
CF10 IF(R11.EQ.0)R11=2.9
C IF P11.NE.0 RANGE IS CHANGED FROM 2
CF IF(JA.EQ.5)RC=-1
C******↑↑↑↑↑↑↑ WAS 8????
CF DO 361 K=1,ITEM
CF IF(FINDIT(K))GO TO 361
C SKIPS NOTES ON WRONG LINE
CF RD=RN(L+3)
CF1 IF(JA.NE.6)GO TO 177
CF IF(IFIX(RN(L+5)/10).NE.X)GO TO 361
CF177 IF(PLACE(R3))GO TO 461
CF R3=RD
C LOOKS FOR NOTE, STAFF #, STEM DIR.
CF IF(JA.EQ.6)GO TO 861
CF IF(JA.EQ.5)GO TO 261
CF RETURN
CF461 IF(JA.EQ.6)GO TO 277
CF IF(JA.NE.5)GO TO 361
CF277 IF(PLACE(R6))GO TO 561
CF R6=RD
CF861 IF(J7.GE.0)GO TO 261
CF561 IF(PLACE(RA))GO TO 661
CF IF(J7)GO TO 761
C J7=NEG MEANS TREMOLO
CF IF(R8.EQ.0)GO TO 361
CF761 R9=RD
C R8=0 MEANS R9 IS NUMBER OUTSIDE OF BEAM.
CF GO TO 261
CF661 IF(JA.EQ.5)GO TO 361
CF IF(J10.LT.30)GO TO 361
CF IF(PLACE(R8))GO TO 361
C HOMES INNER PARTIAL BEAMS
CF R8=RD
CF261 RC=RC+1
CF IF(RC.EQ.1.)RETURN
CF361 CONTINUE
CF END
CF FUNCTION PLACE(X)
CF COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/XRN/RN(2000)
CF EQUIVALENCE (R11,RJQ(9)),(RD,RN(2000))
CF PLACE=R11-ABS(RD-X)
CF END
CF FUNCTION FINDIT(N)
CF COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
CF COMMON /XRN/RN(2000) /PTR/PWDS(250),ITEM,L,I,IX
CF FINDIT=0
CF L=PWDS(N)
CF IF(RN(L+1).NE.1)GO TO 377
CF IF(RN(L+2).EQ.R2)RETURN
CF377 FINDIT=-1
CF END
SUBROUTINE SCL
C SETS UP SCALING MARKERS.
COMMON /STF/RSTFAC(0/7),RSTJ2 /XRN/RN(2000)/RINP/SU(900)
COMMON R2,JA,CT,J2,R3,R4,R5,RJQ(17),J3,J4,J5,J6,J(16)
1 /POSI/STFF(0/7),J102,POS
J2=R2
IF(J2.NE.99)GO TO 1008
CALL HYDPOG(2)
RETURN
1008 J5=0
J6=0
RSTJ2=RSTFAC(J2)
C SETS UP SCALE LINES.
J4=200
IF(R3.NE.0)J4=400
C PUTS SCALE TO 400
R2=STFF(J2)+60.*RSTJ2
RJ=R2+60.
CALL DPYSET(2,SU,700)
CALL DPYBRT(1)
POS=RJ+40.
RSTJ2=1.
DO 1002 MX=10,J4,10
RA=RHORZ(FLOAT(MX))
R3=RA-58
IF(MX.GT.10)CALL PNUM
CC1005 IF(R5.NE.0)GO TO 1007
C JUMP FOR STAFF NUMBERS
CALL LINX(RA,R2,RA,RJ)
J5=J5+1
1002 IF(J5.EQ.10)J5=0
CALL LINES(-596.0,RJ,2)
CALL LINES(-596.0,R2,2)
R6=1.5
C NEXT SETS UP STAFF NUMBERS
R3=-620.
DO 1007 K=0,7
POS=STFF(K)+40.
J5=IABS(K)
CALL PNUM
1007 CONTINUE
CALL DPYOUT(2)
CALL SETPOG(1)
END
C NEXT ALLOWS YOU TO TYPE 'SA NAME' OR 'SAVE NAME' ETC.
C (NO MORE THAN 9 CHARS. MAY COME BEFORE NAME)
CF SUBROUTINE FORMAT(NAME)
C SO WE CAN TYPE 'SA NAME' OR 'SAVE NAME', ETC.
CF COMMON /ALF/INP(72),ML
CF DIMENSION DMY(50),IFMT(2)
CF EQUIVALENCE (INP(20),DMY)
CF DATA IFMT(2)/' ,A5)'/
CF DO 1 K=2,72
CF IF(INP(K).NE.' ')GO TO 1
CF DO 2 L=K+1,72
CF IF(INP(L).EQ.' ')GO TO 2
C NOW WE START NAME
CF L=L-1
CF5 IFMT(1)='( 0A1'+L*32768
C 32768 IS MAGIC NUM TO CHANGE '0' TO RIGHT NUM.
CF REREAD IFMT,(DMY(K),K=1,L),NAME
CF RETURN
CF2 CONTINUE
CF NAME=' '
CF RETURN
CF1 CONTINUE
CF END
SUBROUTINE NAMEXT(JA,NAME,IEXT)
DIMENSION JA(1),A(5),FM(7)
DATA A/'A1','A2','A3','A4','A5'/,FM(1)/'('/
EQUIVALENCE (A5,A(5)),(FM2,FM(2)),(FM3,FM(3)),(FM4,FM(4)),
1 (FM5,FM(5)),(FM6,FM(6)),(FM7,FM(7)),(A3,A(3))
DO 9 K=2,7
9 FM(K)=' '
ID=0
IA=0
NAME=' '
DO 1 K=20,1,-1
IF(JA(K).EQ.' ')GO TO 1
5 DO 2 L=K-1,1,-1
J=JA(L)
IF(J.NE.' ')GO TO 3
IA=L
GO TO 4
3 IF(J.NE.'.')GO TO 2
ID=L
K=L
C '.' ASSUMES THERE IS AN EXTENSION
GO TO 5
2 CONTINUE
GO TO 4
1 CONTINUE
C ALL BLANK IF WE GET HERE
RETURN
4 IF(IA.NE.0)GO TO 6
IF(JA(1).EQ.-1)RETURN
C ↑↑↑ FOR 'RS', 'SA', 'G', ETC. WITH NO NAME FOLLOWING.
IF(ID.NE.0)GO TO 7
C NOW ONLY A NAME IS ON THIS LINE
FM2=A5
FM3=')'
REREAD FM,NAME
RETURN
7 FM3=',A1,'
FM2=A(ID-1)
FM4=A3
FM5=')'
C FOUND NAME AND EXTENSION
REREAD FM, NAME,K,IEXT
RETURN
6 IF(IA.GT.5)RETURN
C .GT.5 = TOO MUCH IN FRONT OF NAME!!
FM2=A(IA)
FM3=','
IF(ID.NE.0)GO TO 8
FM4=A5
FM5=')'
C FOUND 'WORD', NAME WORD= SA, RS, GM, ETC.
REREAD FM,K,NAME
RETURN
8 FM4=A(ID-IA-1)
FM5=',A1,'
FM6=A3
FM7=')'
REREAD FM,K,NAME,K,IEXT
END